home *** CD-ROM | disk | FTP | other *** search
- (define (inspect . openv)
- (display "SIOD Debugger" standard-output)
- (display (integer->char 10) standard-output)
- (if openv (set! *cenv* openv))
- (set! *cenv* (cons *cenv* '()))
- (do () ((null? *cenv*))
- (display (integer->char 10) standard-output)
- (display "Command (h for help) : " standard-output)
- (case (read standard-input)
- ((e errobj) (print errobj standard-output))
- ((x expression) (print *cargs* standard-output))
- ((p parent)
- (if (car *cenv*)
- (begin (set-cdr! *cenv* (cons (car *cenv*) (cdr *cenv*)))
- (set-car! *cenv* (environment-parent (car *cenv*))))
- (display "There is no parent environment"
- standard-output)))
- ((s son)
- (if (cdr *cenv*)
- (begin (set-car! *cenv* (car (cdr *cenv*)))
- (set-cdr! *cenv* (cdr (cdr *cenv*))))
- (display "There is no son environment"
- standard-output)))
- ((b bindings)
- (if (car *cenv*)
- (print (environment-bindings (car *cenv*))
- standard-output)
- (display "Current environment is the global environment"
- standard-output)))
- ((m message) (display *lasterr* standard-output))
- ((v eval)
- (display "eval >> " standard-output)
- (print (eval (read standard-input) (car *cenv*))
- standard-output))
- ((g go)
- (set! errobj '())
- (set! *cenv* '())
- (set! *cargs* '()))
- ((q quit)
- (set! errobj '())
- (set! *cenv* '())
- (set! *cargs* '())
- (reset))
- ((h help)
- (display "e / errobj -- shows errobj" standard-output)
- (display (integer->char 10) standard-output)
- (display "b / bindings -- shows current environment bindings" standard-output)
- (display (integer->char 10) standard-output)
- (display "x / expression -- shows current expression" standard-output)
- (display (integer->char 10) standard-output)
- (display "p / parent -- move up to parent environment" standard-output)
- (display (integer->char 10) standard-output)
- (display "s / son -- move down to son environment" standard-output)
- (display (integer->char 10) standard-output)
- (display "q / quit -- quits SIOD Debugger" standard-output)
- (display (integer->char 10) standard-output)
- (display "g / go -- resumes execution in a breakpoint" standard-output)
- (display (integer->char 10) standard-output)
- (display "m / message -- shows the last error message" standard-output)
- (display (integer->char 10) standard-output))
- (else (display "Unknown command" standard-output)
- (display (integer->char 10) standard-output)))))
-